home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / MacPerl 506 appl folder.sit / MacPerl 506 appl folder / Mac_Perl_506r1m_appl / lib / FileHandle.pm < prev    next >
Text File  |  1995-03-20  |  4KB  |  175 lines
  1. package FileHandle;
  2.  
  3. # Note that some additional FileHandle methods are defined in POSIX.pm.
  4.  
  5. require 5.000;
  6. use English;
  7. use Exporter;
  8.  
  9. @ISA = qw(Exporter);
  10. @EXPORT = qw(
  11.     print
  12.     autoflush
  13.     output_field_separator
  14.     output_record_separator
  15.     input_record_separator
  16.     input_line_number
  17.     format_page_number
  18.     format_lines_per_page
  19.     format_lines_left
  20.     format_name
  21.     format_top_name
  22.     format_line_break_characters
  23.     format_formfeed
  24.     cacheout
  25. );
  26.  
  27. sub print {
  28.     local($this) = shift;
  29.     print $this @_;
  30. }
  31.  
  32. sub autoflush {
  33.     local($old) = select($_[0]);
  34.     local($prev) = $OUTPUT_AUTOFLUSH;
  35.     $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
  36.     select($old);
  37.     $prev;
  38. }
  39.  
  40. sub output_field_separator {
  41.     local($old) = select($_[0]);
  42.     local($prev) = $OUTPUT_FIELD_SEPARATOR;
  43.     $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
  44.     select($old);
  45.     $prev;
  46. }
  47.  
  48. sub output_record_separator {
  49.     local($old) = select($_[0]);
  50.     local($prev) = $OUTPUT_RECORD_SEPARATOR;
  51.     $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
  52.     select($old);
  53.     $prev;
  54. }
  55.  
  56. sub input_record_separator {
  57.     local($old) = select($_[0]);
  58.     local($prev) = $INPUT_RECORD_SEPARATOR;
  59.     $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
  60.     select($old);
  61.     $prev;
  62. }
  63.  
  64. sub input_line_number {
  65.     local($old) = select($_[0]);
  66.     local($prev) = $INPUT_LINE_NUMBER;
  67.     $INPUT_LINE_NUMBER = $_[1] if @_ > 1;
  68.     select($old);
  69.     $prev;
  70. }
  71.  
  72. sub format_page_number {
  73.     local($old) = select($_[0]);
  74.     local($prev) = $FORMAT_PAGE_NUMBER;
  75.     $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
  76.     select($old);
  77.     $prev;
  78. }
  79.  
  80. sub format_lines_per_page {
  81.     local($old) = select($_[0]);
  82.     local($prev) = $FORMAT_LINES_PER_PAGE;
  83.     $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
  84.     select($old);
  85.     $prev;
  86. }
  87.  
  88. sub format_lines_left {
  89.     local($old) = select($_[0]);
  90.     local($prev) = $FORMAT_LINES_LEFT;
  91.     $FORMAT_LINES_LEFT = $_[1] if @_ > 1;
  92.     select($old);
  93.     $prev;
  94. }
  95.  
  96. sub format_name {
  97.     local($old) = select($_[0]);
  98.     local($prev) = $FORMAT_NAME;
  99.     $FORMAT_NAME = $_[1] if @_ > 1;
  100.     select($old);
  101.     $prev;
  102. }
  103.  
  104. sub format_top_name {
  105.     local($old) = select($_[0]);
  106.     local($prev) = $FORMAT_TOP_NAME;
  107.     $FORMAT_TOP_NAME = $_[1] if @_ > 1;
  108.     select($old);
  109.     $prev;
  110. }
  111.  
  112. sub format_line_break_characters {
  113.     local($old) = select($_[0]);
  114.     local($prev) = $FORMAT_LINE_BREAK_CHARACTERS;
  115.     $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
  116.     select($old);
  117.     $prev;
  118. }
  119.  
  120. sub format_formfeed {
  121.     local($old) = select($_[0]);
  122.     local($prev) = $FORMAT_FORMFEED;
  123.     $FORMAT_FORMFEED = $_[1] if @_ > 1;
  124.     select($old);
  125.     $prev;
  126. }
  127.  
  128.  
  129. # --- cacheout functions ---
  130.  
  131. # Open in their package.
  132.  
  133. sub cacheout_open {
  134.     my $pack = caller(1);
  135.     open(*{$pack . '::' . $_[0]}, $_[1]);
  136. }
  137.  
  138. sub cacheout_close {
  139.     my $pack = caller(1);
  140.     close(*{$pack . '::' . $_[0]});
  141. }
  142.  
  143. # But only this sub name is visible to them.
  144.  
  145. sub cacheout {
  146.     ($file) = @_;
  147.     if (!$cacheout_maxopen){
  148.     if (open(PARAM,'/usr/include/sys/param.h')) {
  149.         local($.);
  150.         while (<PARAM>) {
  151.         $cacheout_maxopen = $1 - 4
  152.             if /^¥s*#¥s*define¥s+NOFILE¥s+(¥d+)/;
  153.         }
  154.         close PARAM;
  155.     }
  156.     $cacheout_maxopen = 16 unless $cacheout_maxopen;
  157.     }
  158.     if (!$isopen{$file}) {
  159.     if (++$cacheout_numopen > $cacheout_maxopen) {
  160.         local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
  161.         splice(@lru, $cacheout_maxopen / 3);
  162.         $cacheout_numopen -= @lru;
  163.         for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
  164.     }
  165.     &cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file)
  166.         || croak("Can't create $file: $!");
  167.     }
  168.     $isopen{$file} = ++$cacheout_seq;
  169. }
  170.  
  171. $cacheout_seq = 0;
  172. $cacheout_numopen = 0;
  173.  
  174. 1;
  175.